!! Copyright (C) 2009,2010,2011,2012  Marco Restelli
!!
!! This file is part of:
!!   FEMilaro -- Finite Element Method toolkit
!!
!! FEMilaro is free software; you can redistribute it and/or modify it
!! under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 3 of the License, or
!! (at your option) any later version.
!!
!! FEMilaro is distributed in the hope that it will be useful, but
!! WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
!! General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with FEMilaro; If not, see <http://www.gnu.org/licenses/>.
!!
!! author: Marco Restelli                   <marco.restelli@gmail.com>

!>\brief
!! Dummy interface to MPI.
!!
!! \n
!!
!! This module provides some stubs for MPI functions. There are three
!! kinds of stubs:
!! <ol>
!!  <li> those which don't do anything
!!  <li> those which return some "simple" default value
!!  <li> those which produce an error (and thus should never be
!!  called)
!! </ol>
!!
!! \note This module is a replacement of \link mod_mpi_utils.f90
!! mod_mpi_utils.
!!
!! \section status MPI status objects
!!
!! According to the MPI standard, we always return a status object
!! corresponding to communication from processor 0, with tag 1 and no
!! error. This is obtained by setting <tt>status(mpi_source)=0</tt>,
!! <tt>status(mpi_tag)=1</tt>, <tt>status(mpi_error)=mpi_success</tt>.
!!
!! \section externals External subroutines
!! 
!! MPI subroutine are often called violating the f90 standard, and
!! relying on f77 conventions (nonstandard) for argument passing. To
!! make this possible in the present module, certain subroutines are
!! implemented as external procedures.
!!
!! \warning This module should be compiled with all the debugging
!! options turned off, so that the compiler can not detect our tricks.
!<----------------------------------------------------------------------
module mod_mpi_utils

!-----------------------------------------------------------------------

 use mod_messages, only: &
   mod_messages_initialized, &
   error,   &
   warning, &
   info

 use mod_kinds, only: &
   mod_kinds_initialized, &
   wp, wp_p, wp_r

!-----------------------------------------------------------------------
 
 implicit none

!-----------------------------------------------------------------------

! Module interface

 public :: &
   mod_mpi_utils_constructor, &
   mod_mpi_utils_destructor,  &
   mod_mpi_utils_initialized, &
   mpi_logical, mpi_integer, wp_mpi, &
   mpi_comm_world, mpi_status_size,  &
   mpi_sum, mpi_max, mpi_lor,        &
   mpi_init, mpi_finalize,           &
   mpi_comm_size, mpi_comm_rank,     &
   mpi_barrier,                      &
   mpi_bcast,                        &
   mpi_isend, mpi_irecv,             &
   mpi_send,  mpi_recv,              &
   mpi_request_null,                 &
   mpi_comm_split,                   &
   mpi_comm_free,                    &
   mpi_undefined,                    &
   mpi_wait, mpi_waitall,            &
   mpi_sendrecv,                     &
   mpi_reduce, mpi_allreduce,        &
   mpi_alltoall, mpi_alltoallv,      &
   mpi_allgather,                    &
   ! used by the external subroutines
   this_mod_name, error_msg, error, warning, info, mpi_success

 private

!-----------------------------------------------------------------------

! Module types and parameters

! Module variables

 ! public members
 external :: mpi_send, mpi_recv, mpi_isend, mpi_irecv, mpi_bcast, &
   mpi_alltoall, mpi_alltoallv, mpi_allreduce, mpi_allgather

 integer, parameter :: &
   mpi_logical = 1111, &
   mpi_integer = 2222, &
   wp_mpi = wp

 integer, parameter :: &
   mpi_success = 0, &
   mpi_comm_world   = 1001, &
   mpi_comm_null    = 1002, &
   mpi_request_null = 1003, &
   mpi_undefined    = 1004, &
   mpi_sum = -1, mpi_max = -1, mpi_lor = -1

 integer, parameter :: &
   mpi_status_size = 3,                                      &
   mpi_source = 1, mpi_tag = 2, mpi_error = 3,               &
   default_status(mpi_status_size) = (/ 0 , 1 , mpi_success /)

 character(len=*), parameter :: &
   this_mod_name = 'mod_mpi_utils'

 logical, protected ::               &
   mod_mpi_utils_initialized = .false.

 ! private members
 character(len=*), parameter :: error_msg = &
   "This is not a real MPI implementation and should not be called."

!-----------------------------------------------------------------------

contains

!-----------------------------------------------------------------------

 subroutine mod_mpi_utils_constructor()
  character(len=*), parameter :: &
    this_sub_name = 'constructor'

   !Consistency checks ---------------------------
   if( (mod_messages_initialized.eqv..false.) ) then
     call error(this_sub_name,this_mod_name, &
                'Not all the required modules are initialized.')
   endif
   if(mod_mpi_utils_initialized.eqv..true.) then
     call warning(this_sub_name,this_mod_name, &
                  'Module is already initialized.')
   endif
   !----------------------------------------------

   mod_mpi_utils_initialized = .true.
 end subroutine mod_mpi_utils_constructor

!-----------------------------------------------------------------------
 
 subroutine mod_mpi_utils_destructor()
  character(len=*), parameter :: &
    this_sub_name = 'destructor'
   
   !Consistency checks ---------------------------
   if(mod_mpi_utils_initialized.eqv..false.) then
     call error(this_sub_name,this_mod_name, &
                'This module is not initialized.')
   endif
   !----------------------------------------------

   mod_mpi_utils_initialized = .false.
 end subroutine mod_mpi_utils_destructor

!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
! *********************************************************************
!  Functions returning a value corresponding to the single process case
! *********************************************************************
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------

 pure subroutine mpi_init(ierror)
  integer, intent(out) :: ierror
   ierror = mpi_success
 end subroutine mpi_init
 
!-----------------------------------------------------------------------

 pure subroutine mpi_finalize(ierror)
  integer, intent(out) :: ierror
   ierror = mpi_success
 end subroutine mpi_finalize
 
!-----------------------------------------------------------------------
 
 pure subroutine mpi_comm_size(comm,size,ierror)
  integer, intent(in) :: comm
  integer, intent(out) :: size, ierror
   size = 1
   ierror = mpi_success
 end subroutine mpi_comm_size
 
!-----------------------------------------------------------------------

 pure subroutine mpi_comm_rank(comm,rank,ierror)
  integer, intent(in) :: comm
  integer, intent(out) :: rank, ierror
   rank = 0
   ierror = mpi_success
 end subroutine mpi_comm_rank
 
!-----------------------------------------------------------------------

 pure subroutine mpi_comm_split(comm,color,key,comm_cart,ierror)
  integer, intent(in) :: comm, color, key
  integer, intent(out) :: comm_cart, ierror
   if(color.eq.mpi_undefined) then
     comm_cart = mpi_comm_null
   else
     comm_cart = mpi_comm_world
   endif
   ierror = mpi_success
 end subroutine mpi_comm_split
 
!-----------------------------------------------------------------------

 pure subroutine mpi_comm_free(comm,ierror)
  integer, intent(in) :: comm
  integer, intent(out) :: ierror
   ierror = mpi_success
 end subroutine mpi_comm_free
 
!-----------------------------------------------------------------------

 pure subroutine mpi_barrier(comm,ierror)
  integer, intent(in) :: comm
  integer, intent(out) :: ierror
   ierror = mpi_success
 end subroutine mpi_barrier
 
!-----------------------------------------------------------------------

 subroutine mpi_wait(request,status,ierror)
  integer, intent(inout) :: request
  integer, intent(out) :: status(mpi_status_size)
  integer, intent(out) :: ierror
  character(len=*), parameter :: this_sub_name = "mpi_wait"

   request = mpi_request_null
   status = default_status
   ierror = mpi_success
 end subroutine mpi_wait

!-----------------------------------------------------------------------

 subroutine mpi_waitall(count,array_of_reqsts,array_of_stses,ierror)
  integer, intent(in) :: count
  integer, intent(inout) :: array_of_reqsts(count)
  integer, intent(out) :: array_of_stses(mpi_status_size,count)
  integer, intent(out) :: ierror
  character(len=*), parameter :: this_sub_name = "mpi_waitall"

  integer :: q

   do q=1,count
     array_of_reqsts(q) = mpi_request_null
     array_of_stses(:,q) = default_status
   enddo
   ierror = mpi_success
 end subroutine mpi_waitall
 
!-----------------------------------------------------------------------

 subroutine mpi_reduce(sendbuf,recvbuf,count,datatype,op,root,comm,ierror)
  integer, intent(in) :: count, datatype, op, root, comm
  integer, intent(in) :: sendbuf(count)
  integer, intent(out) :: recvbuf(count)
  integer, intent(out) :: ierror
  character(len=*), parameter :: this_sub_name = "mpi_reduce"

   recvbuf = sendbuf
   ierror = mpi_success
 end subroutine mpi_reduce
 
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
! *********************************************************************
!  Functions returning an error
! *********************************************************************
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------

 subroutine mpi_sendrecv(sendbuf,sendcnt,sendtype,dest,sendtag, &
                         recvbuf,recvcnt,recvtype,srce,recvtag, &
                         comm,status,ierror)
  integer, intent(in) :: sendbuf(*)
  integer, intent(out) :: recvbuf(*)
  integer, intent(in) :: sendcnt, sendtype, dest, sendtag, recvcnt, &
    recvtype, srce, recvtag, comm
  integer, intent(out) :: status(mpi_status_size), ierror
  character(len=*), parameter :: this_sub_name = "mpi_sendrecv"

   call error(this_sub_name,this_mod_name,error_msg)
 end subroutine mpi_sendrecv

!-----------------------------------------------------------------------

end module mod_mpi_utils

!-----------------------------------------------------------------------
! *********************************************************************
!  External subroutines
! *********************************************************************
!-----------------------------------------------------------------------

subroutine mpi_send(buf,count,datatype,dest,tag,comm,ierror)

 use mod_mpi_utils, only: error, this_mod_name, error_msg
 implicit none

 integer, intent(in) :: buf(*)
 integer, intent(in) :: count, datatype, dest, tag, comm
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_send"

  call error(this_sub_name,this_mod_name,error_msg)
end subroutine mpi_send

!-----------------------------------------------------------------------

subroutine mpi_recv(buf,count,datatype,source,tag,comm,status,ierror)

 use mod_mpi_utils, only: error, this_mod_name, error_msg, &
   mpi_status_size
 implicit none

 integer, intent(out) :: buf(*)
 integer, intent(in) :: count, datatype, source, tag, comm, &
   status(mpi_status_size)
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_recv"

  call error(this_sub_name,this_mod_name,error_msg)
end subroutine mpi_recv

!-----------------------------------------------------------------------
 
subroutine mpi_alltoall(sendbuf,sendcnts,sendtype, &
                        recvbuf,recvcnts,recvtype,comm,ierror)

 use mod_mpi_utils, only: error, this_mod_name, mpi_success, &
   mpi_logical, mpi_integer, wp_mpi
 implicit none

 integer, intent(in) :: sendcnts, sendtype, &
   recvcnts, recvtype, comm
 integer, intent(in) :: sendbuf(*)
 integer, intent(out) :: recvbuf(*), ierror
 character(len=*), parameter :: this_sub_name = "mpi_alltoall"

 external :: copy_logical_array, copy_integer_array, copy_real_array

  select case(sendtype)
   case(mpi_logical)
    call copy_logical_array(recvbuf,recvcnts,sendbuf,sendcnts)
   case(mpi_integer)
    call copy_integer_array(recvbuf,recvcnts,sendbuf,sendcnts)
   case(wp_mpi)
    call copy_real_array(   recvbuf,recvcnts,sendbuf,sendcnts)
   case default
    call error(this_sub_name,this_mod_name,'Unknown type.')
  end select
  ierror = mpi_success
end subroutine mpi_alltoall
 
!-----------------------------------------------------------------------

subroutine mpi_alltoallv(sendbuf,sendcnts,sdispls,sendtype, &
                         recvbuf,recvcnts,rdispls,recvtype,comm,ierror)

 use mod_mpi_utils, only: error, this_mod_name, mpi_success, &
   mpi_logical, mpi_integer, wp_mpi
 implicit none

 integer, intent(in) :: sendcnts(*), sdispls(*), sendtype, &
   recvcnts(*), rdispls(*), recvtype, comm
 integer, intent(in) :: sendbuf(*)
 integer, intent(out) :: recvbuf(*), ierror
 character(len=*), parameter :: this_sub_name = "mpi_alltoallv"

 external :: copy_logical_array, copy_integer_array, copy_real_array

  select case(sendtype)
   case(mpi_logical)
    call copy_logical_array( recvbuf(sdispls(1)+1),recvcnts(1), &
                             sendbuf(rdispls(1)+1),sendcnts(1)  )
   case(mpi_integer)
    call copy_integer_array( recvbuf(sdispls(1)+1),recvcnts(1), &
                             sendbuf(rdispls(1)+1),sendcnts(1)  )
   case(wp_mpi)
    call copy_real_array(    recvbuf(sdispls(1)+1),recvcnts(1), &
                             sendbuf(rdispls(1)+1),sendcnts(1)  )
   case default
    call error(this_sub_name,this_mod_name,'Unknown type.')
  end select
  ierror = mpi_success
end subroutine mpi_alltoallv
 
!-----------------------------------------------------------------------

subroutine mpi_bcast(buf,count,datatype,root,comm,ierror)

 use mod_mpi_utils, only: mpi_success
 implicit none

 integer, intent(in) :: count, datatype, root, comm
 integer, intent(inout) :: buf(*)
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_bcast"

  ierror = mpi_success
end subroutine mpi_bcast
 
!-----------------------------------------------------------------------

subroutine mpi_isend(buf,count,dtype,dest,tag,comm,request,ierror)

 use mod_mpi_utils, only: error, this_mod_name, error_msg
 implicit none

 integer, intent(in) :: buf(*)
 integer, intent(in) :: count, dtype, dest, tag, comm, request
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_isend"

  call error(this_sub_name,this_mod_name,error_msg)
end subroutine mpi_isend
 
!-----------------------------------------------------------------------

subroutine mpi_irecv(buf,count,dtype,source,tag,comm,request,ierror)

 use mod_mpi_utils, only: error, this_mod_name, error_msg
 implicit none

 integer, intent(out) :: buf(*)
 integer, intent(in) :: count, dtype, source, tag, comm, request
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_irecv"

  call error(this_sub_name,this_mod_name,error_msg)
end subroutine mpi_irecv
 
!-----------------------------------------------------------------------

subroutine mpi_allreduce(sendbuf,recvbuf,count,datatype,op,comm,ierror)

 use mod_mpi_utils, only: error, this_mod_name, mpi_success, &
   mpi_logical, mpi_integer, wp_mpi
 implicit none

 integer, intent(in) :: count, datatype, op, comm
 integer, intent(in) :: sendbuf(*)
 integer, intent(out) :: recvbuf(*)
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_allreduce"

 external :: copy_logical_array, copy_integer_array, copy_real_array

  select case(datatype)
   case(mpi_logical)
    call copy_logical_array(recvbuf,count,sendbuf,count)
   case(mpi_integer)
    call copy_integer_array(recvbuf,count,sendbuf,count)
   case(wp_mpi)
    call copy_real_array(   recvbuf,count,sendbuf,count)
   case default
    call error(this_sub_name,this_mod_name,'Unknown type.')
  end select
  ierror = mpi_success
end subroutine mpi_allreduce

!-----------------------------------------------------------------------

subroutine mpi_allgather(sendbuf,sendcount,sendtype,            &
                         recvbuf,recvcount,recvtype, comm,ierror)

 use mod_mpi_utils, only: error, this_mod_name, mpi_success, &
   mpi_logical, mpi_integer, wp_mpi
 implicit none

 integer, intent(in) :: sendcount, sendtype, recvcount, recvtype
 integer, intent(in) :: comm
 integer, intent(in) :: sendbuf(*)
 integer, intent(out) :: recvbuf(*)
 integer, intent(out) :: ierror
 character(len=*), parameter :: this_sub_name = "mpi_allgather"

 external :: copy_logical_array, copy_integer_array, copy_real_array

  select case(sendtype)
   case(mpi_logical)
    call copy_logical_array(recvbuf,recvcount,sendbuf,sendcount)
   case(mpi_integer)
    call copy_integer_array(recvbuf,recvcount,sendbuf,sendcount)
   case(wp_mpi)
    call copy_real_array(   recvbuf,recvcount,sendbuf,sendcount)
   case default
    call error(this_sub_name,this_mod_name,'Unknown type.')
  end select
  ierror = mpi_success
end subroutine mpi_allgather

!-----------------------------------------------------------------------

subroutine copy_logical_array(dest,dcnt,source,scnt)
 implicit none
 logical, intent(out) :: dest(*)
 logical, intent(in) :: source(*)
 integer, intent(in) :: dcnt, scnt
  dest(1:dcnt) = source(1:scnt)
end subroutine copy_logical_array

!-----------------------------------------------------------------------

subroutine copy_integer_array(dest,dcnt,source,scnt)
 implicit none
 integer, intent(out) :: dest(*)
 integer, intent(in) :: source(*)
 integer, intent(in) :: dcnt, scnt
  dest(1:dcnt) = source(1:scnt)
end subroutine copy_integer_array

!-----------------------------------------------------------------------

subroutine copy_real_array(dest,dcnt,source,scnt)
 use mod_mpi_utils
 implicit none
 real(wp_mpi), intent(out) :: dest(*)
 real(wp_mpi), intent(in) :: source(*)
 integer, intent(in) :: dcnt, scnt
  dest(1:dcnt) = source(1:scnt)
end subroutine copy_real_array

